home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 008 / cadence.arc / VOL2NO4.ARC / CSPLINE5.LSP < prev    next >
Encoding:
Text File  |  1987-05-18  |  5.4 KB  |  193 lines
  1. ;5 pt. Cubic Spline
  2. ;         by          TIMOTHY L. GRANT      c. 1987
  3. ;
  4. (defun C:SPLINE ()
  5.  (defun CMDPROMPT ()
  6.    (defun *error* (st)
  7.      (setq *error* nil)
  8.      (princ))
  9.   (quit))
  10. ;
  11.  (SETVAR "CMDECHO" 0)
  12.  (SETQ N 5)
  13.  (SETQ P1 (GETPOINT "\nPick point:"))
  14.  (SETQ P2 (GETPOINT "\nPick point:"))
  15.  (SETQ P3 (GETPOINT "\nPick point:"))
  16.  (SETQ P4 (GETPOINT "\nPick point:"))
  17.  (SETQ P5 (GETPOINT "\nPick point:"))
  18.  (SETQ X1 (CAR P1))
  19.  (SETQ Y1 (CADR P1))
  20.  (SETQ X2 (CAR P2))
  21.  (SETQ Y2 (CADR P2))
  22.  (SETQ X3 (CAR P3))
  23.  (SETQ Y3 (CADR P3)) 
  24.  (SETQ X4 (CAR P4))
  25.  (SETQ Y4 (CADR P4))
  26.  (SETQ X5 (CAR P5))
  27.  (SETQ Y5 (CADR P5))
  28.  (SETQ NSPLINE 20) ;                                        # pts. on spline
  29.  (SETQ T1 0)
  30.  (SETQ T2 (+ T1 (DISTANCE P1 P2)))
  31.  (SETQ T3 (+ T2 (DISTANCE P2 P3)))
  32.  (SETQ T4 (+ T3 (DISTANCE P3 P4)))
  33.  (SETQ T5 (+ T4 (DISTANCE P4 P5)))
  34. ;
  35.  (SETQ J (GETREAL "\n Beginning Curvature Coeff.:"))
  36.  (SETQ K (GETREAL "\n Ending Curvature Coeff.:"))
  37. ;              Compute spline on t,x & t,y
  38. ;              1st differences
  39.  (SETQ H1 (- T2 T1))
  40.  (SETQ H2 (- T3 T2))
  41.  (SETQ H3 (- T4 T3))
  42.  (SETQ H4 (- T5 T4))
  43.  (SETQ C2 (+ (* (+ 2 J) H1) (* 2 H2)))
  44.  (SETQ C3 (* 2 (+ H2 H3)))
  45.  (SETQ C4 (+ (* (+ 2 K) H4) (* 2 H3)))
  46. ;
  47.  (SETQ DX2 (* 6 (- (/ (- X3 X2) H2) (/ (- X2 X1) H1))))
  48.  (SETQ DX3 (* 6 (- (/ (- X4 X3) H3) (/ (- X3 X2) H2))))
  49.  (SETQ DX4 (* 6 (- (/ (- X5 X4) H4) (/ (- X4 X3) H3))))
  50. ;
  51.  (SETQ DY2 (* 6 (- (/ (- Y3 Y2) H2) (/ (- Y2 Y1) H1))))
  52.  (SETQ DY3 (* 6 (- (/ (- Y4 Y3) H3) (/ (- Y3 Y2) H2))))
  53.  (SETQ DY4 (* 6 (- (/ (- Y5 Y4) H4) (/ (- Y4 Y3) H3))))
  54. ;
  55.  (SETQ C3 (- C3 (/ (* H2 H2) C2)))
  56.  (SETQ C4 (- C4 (/ (* H3 H3) C3)))
  57.  (SETQ DX3 (- DX3 (/ (* DX2 H2) C2)))
  58.  (SETQ DX4 (- DX4 (/ (* DX3 H3) C3)))
  59.  (SETQ DY3 (- DY3 (/ (* DY2 H2) C2)))
  60.  (SETQ DY4 (- DY4 (/ (* DY3 H3) C3)))
  61. ;
  62.  (SETQ GX4 (/ DX4 C4))
  63.  (SETQ GX3 (/ (- DX3 (* H3 GX4)) C3))
  64.  (SETQ GX2 (/ (- DX2 (* H2 GX3)) C2))
  65.  (SETQ GX1 (* J GX2))
  66.  (SETQ GX5 (* K GX4))
  67. ;
  68.  (SETQ GY4 (/ DY4 C4))
  69.  (SETQ GY3 (/ (- DY3 (* H3 GY4)) C3))
  70.  (SETQ GY2 (/ (- DY2 (* H2 GY3)) C2))
  71.  (SETQ GY1 (* J GY2))
  72.  (SETQ GY5 (* K GY4))
  73. ;
  74.  (SETQ DT (/ T5 NSPLINE))
  75.  (SETQ WT 0)
  76.  (SETQ IX1 X1)
  77.  (SETQ IY1 Y1)
  78. ;                  compute and plot interpolated values
  79.  (WHILE (<= WT T2)                  ; interval T1 - T2
  80.   (SETQ H (- WT T1))
  81.   (SETQ K1 (- T2 WT))
  82.   (SETQ K1C (* K1 K1 K1))
  83.   (SETQ K2 (- WT T1))
  84.   (SETQ K2C (* K2 K2 K2))
  85.   (SETQ IX2 (/ (* GX1 (- (/ K1C H1) (* H1 K1))) 6))
  86.   (SETQ IX2 (+ IX2 (/ (* GX2 (- (/ K2C H1)(* H1 K2))) 6)))
  87.   (SETQ IX2 (+ IX2 (* X1 (/ K1 H1))))
  88.   (SETQ IX2 (+ IX2 (* X2 (/ K2 H1))))
  89. ;
  90.   (SETQ IY2 (/ (* GY1 (- (/ K1C H1) (* H1 K1))) 6))
  91.   (SETQ IY2 (+ IY2 (/ (* GY2 (- (/ K2C H1)(* H1 K2))) 6)))
  92.   (SETQ IY2 (+ IY2 (* Y1 (/ K1 H1)))) 
  93.   (SETQ IY2 (+ IY2 (* Y2 (/ K2 H1))))
  94. ;
  95.   (SETQ S1 (LIST IX1 IY1))
  96.   (SETQ S2 (LIST ix2 iy2))
  97.   (COMMAND "LINE" S1 S2 "")
  98. ; (COMMAND "")
  99. ;
  100.   (SETQ IX1 IX2)
  101.   (SETQ IY1 IY2)
  102. ;
  103.   (SETQ WT (+ WT DT))
  104.  )                                 ;wend
  105. ;
  106.  (WHILE (<= WT T3)                 ; interval T2 - T3
  107.   (SETQ H (- WT T2))
  108.   (SETQ K1 (- T3 WT))
  109.   (SETQ K1C (* K1 K1 K1))
  110.   (SETQ K2 (- WT T2)) 
  111.   (SETQ K2C (* K2 K2 K2))
  112.   (SETQ IX2 (/ (* GX2 (- (/ K1C H2) (* H2 K1))) 6))
  113.   (SETQ IX2 (+ IX2 (/ (* GX3 (- (/ K2C H2)(* H2 K2))) 6)))
  114.   (SETQ IX2 (+ IX2 (* X2 (/ K1 H2))))
  115.   (SETQ IX2 (+ IX2 (* X3 (/ K2 H2))))
  116. ;
  117.   (SETQ IY2 (/ (* GY2 (- (/ K1C H2) (* H2 K1))) 6))
  118.   (SETQ IY2 (+ IY2 (/ (* GY3 (- (/ K2C H2)(* H2 K2))) 6)))
  119.   (SETQ IY2 (+ IY2 (* Y2 (/ K1 H2))))
  120.   (SETQ IY2 (+ IY2 (* Y3 (/ K2 H2))))
  121. ;
  122.    (SETQ S1 (LIST IX1 IY1))
  123.    (SETQ S2 (LIST IX2 IY2))
  124.    (COMMAND "LINE" S1 S2 "")
  125. ;  (COMMAND "")
  126. ;
  127.   (SETQ IX1 IX2)
  128.   (SETQ IY1 IY2)
  129. ;
  130.   (SETQ WT (+ WT DT))
  131.  )                                 ;wend
  132. ;
  133.  (WHILE (<= WT T4)                 ; interval T3 - T4
  134.   (SETQ H (- WT T3))
  135.   (SETQ K1 (- T4 WT))
  136.   (SETQ K1C (* K1 K1 K1))
  137.   (SETQ K2 (- WT T3))
  138.   (SETQ K2C (* K2 K2 K2))
  139.   (SETQ IX2 (/ (* GX3 (- (/ K1C H3) (* H3 K1))) 6))
  140.   (SETQ IX2 (+ IX2 (/ (* GX4 (- (/ K2C H3)(* H3 K2))) 6)))
  141.   (SETQ IX2 (+ IX2 (* X3 (/ K1 H3))))
  142.   (SETQ IX2 (+ IX2 (* X4 (/ K2 H3))))
  143. ;
  144.   (SETQ IY2 (/ (* GY3 (- (/ K1C H3) (* H3 K1))) 6))
  145.   (SETQ IY2 (+ IY2 (/ (* GY4 (- (/ K2C H3)(* H3 K2))) 6)))
  146.   (SETQ IY2 (+ IY2 (* Y3 (/ K1 H3))))
  147.   (SETQ IY2 (+ IY2 (* Y4 (/ K2 H3))))
  148. ;
  149.    (SETQ S1 (LIST IX1 IY1))
  150.    (SETQ S2 (LIST IX2 IY2))
  151.    (COMMAND "LINE" S1 S2 "")
  152. ;  (COMMAND "")
  153. ;
  154.   (SETQ IX1 IX2)
  155.   (SETQ IY1 IY2)
  156. ;
  157.   (SETQ WT (+ WT DT))
  158.  )                                 ;wend
  159. ;
  160.  (WHILE (<= WT T5)                 ; interval T4 - T5
  161.   (SETQ H (- WT T4))
  162.   (SETQ K1 (- T5 WT))
  163.   (SETQ K1C (* K1 K1 K1))
  164.   (SETQ K2 (- WT T4))
  165.   (SETQ K2C (* K2 K2 K2))
  166.   (SETQ IX2 (/ (* GX4 (- (/ K1C H4) (* H4 K1))) 6))
  167.   (SETQ IX2 (+ IX2 (/ (* GX5 (- (/ K2C H4)(* H4 K2))) 6)))
  168.   (SETQ IX2 (+ IX2 (* X4 (/ K1 H4))))
  169.   (SETQ IX2 (+ IX2 (* X5 (/ K2 H4))))
  170. ;
  171.   (SETQ IY2 (/ (* GY4 (- (/ K1C H4) (* H4 K1))) 6))
  172.   (SETQ IY2 (+ IY2 (/ (* GY5 (- (/ K2C H4)(* H4 K2))) 6)))
  173.   (SETQ IY2 (+ IY2 (* Y4 (/ K1 H4))))
  174.   (SETQ IY2 (+ IY2 (* Y5 (/ K2 H4))))
  175. ;
  176.    (SETQ S1 (LIST IX1 IY1))
  177.    (SETQ S2 (LIST IX2 IY2))
  178.    (COMMAND "LINE" S1 S2 "")
  179. ;  (COMMAND "")
  180. ;
  181.   (SETQ IX1 IX2)
  182.   (SETQ IY1 IY2)
  183. ;
  184.   (SETQ WT (+ WT DT))
  185.  )                                 ;wend
  186. ;  
  187.   (SETQ S1 (LIST IX1 IY1))
  188.   (COMMAND "LINE" S1 P5 "")
  189. ; (COMMAND "")
  190. ;
  191.  (GC)
  192.  (CMDPROMPT))
  193.